;;;; Created on 2007-05-04 06:43:15




;; Converts a set of values to an ordering
(defun genes-to-schedule (genes)
  (let ((genes-wrapped nil)
        (cur 0))
    (dolist (g genes)
      (setf genes-wrapped (cons (list g cur) genes-wrapped))
      (setf cur (1+ cur)))
    (setf genes-wrapped (sort genes-wrapped #'(lambda (a b)
                            (< (car a) (car b)))))
    (mapcar #'cadr genes-wrapped)))
    
;; Creates a population of schedules 
(defun make-population (elements n)
  (let ((result nil)
        (cur nil))
    (dotimes (i n)
      (setf cur nil)
      (dotimes (k elements)
        (setf cur (cons (random 1.0) cur)))
      (setf result (cons cur result)))
    result))


;; Creates a set of the genes with a cdr of their value of the passed operation and car as the genes
;; Later will sort and try to minimize the test
(defun eval-population (population test)
  (mapcar #'(lambda (a) (cons a (funcall test a))) population))
  

;; Evaluates and then sorts the population, keeping the eval changes
(defun eval-sort-population (population test)
  (let ((result (eval-population population test)))
    (sort result #'(lambda (a b) (< (cdr a) (cdr b))))))



;; Randomly crossover each gene, favor p1 by the value favoritism
(defun uniform-crossover (p1 p2 &optional (favoritism 0.7))
  (let ((child nil))
    (dotimes (i (length p1))
      (if (< (random 1.0) favoritism)
          (setf child (cons (nth i p1) child))
          (setf child (cons (nth i p2) child))))
    (reverse child)))


;; A simple policy, assumes all other values are crossover
(defstruct generation-policy 
  (elite 0.2)
  (rand 0.05)
  (crossover-func #'uniform-crossover)
  (eval-func #'min))


;; Takes a sorted population with eval values attached and a policy and creates the next generation
(defun next-generation (sorted-population &optional (policy (make-generation-policy)))
  (let* ((gen-x nil)
         (gen-size (length sorted-population))
         (elites (round (* (generation-policy-elite policy) gen-size)))
         (randoms (round (* (generation-policy-rand policy) gen-size)))
         (crossovers (- gen-size elites randoms))
         (cur 0))
    (dolist (c sorted-population)
      (if (>= cur elites)
          (return)
          (progn
            (setf gen-x (cons (car c) gen-x))
            (setf cur (1+ cur)))))
    (setf gen-x (append gen-x (make-population (length (car (car sorted-population))) randoms)))
    (dotimes (i crossovers)
      (setf gen-x (cons 
                    (funcall (generation-policy-crossover-func policy)
                             (car (elt sorted-population (random gen-size)))
                             (car (elt sorted-population (random gen-size))))
                    gen-x)))
    gen-x))





;; Sum mins of a list of jobs
(defun sum-mins (jobs)
  (let ((result 0))
    (dolist (j jobs)
      (setf result (+ result (list-min j))))
    result))

(defun list-min (lst)
  (let ((best 1e38))
    (dolist (c lst)
      (if (< c best)
          (setf best c)))
    best))

(defun genes-to-tardiness (genes jobs machines &optional (event-queue (create-heap 'less-event)))
  (sum-tardiness (run-jobs (arb-ordering jobs (genes-to-schedule genes)) machines event-queue)))

;; Solves for a given job shop
(defun learn-shop (jobs machines &optional (gen-size 100) (max-generations 1000) (term-val -1e38))
  ;(test-basics jobs machines)
  (let* ((pop (make-population (length jobs) gen-size))
         (sorted-pop nil)
         (test-jobs jobs)
         (event-queue (create-heap 'less-event))
         (job-policy
           (make-generation-policy
             :eval-func #'(lambda (a)
                            (genes-to-tardiness a test-jobs machines event-queue))))
         (best-val 1e38)
         (best-seq nil))
    (setf (bytes-consed-between-gcs) 100663296)
    (dotimes (i max-generations)
      (if (= (mod i 20) 0)
          (gc :full t)
          (gc :key 2))
      (setf sorted-pop (eval-sort-population pop (generation-policy-eval-func job-policy)))
   ;Test for best
      (if (< (genes-to-tardiness (car (car sorted-pop)) test-jobs machines) best-val)
          (progn
            (setf best-val (genes-to-tardiness (car (car sorted-pop)) test-jobs machines))
            (setf best-seq (arb-ordering test-jobs (genes-to-schedule (car (car sorted-pop)))))
            (format t "Found best: ~A at gen ~A~%" best-val i); (genes-to-schedule (car (car sorted-pop))))
   ;Test for term-val reached
            (if (<= best-val term-val)
                (return best-seq))))
      (setf pop (next-generation sorted-pop job-policy)))
    (progn
      best-seq)))
      
          

      



#|
SIMPLE TESTING: min
(setf pop (make-population 3 10))
(eval-sort-population pop #'list-min)
(next-generation (eval-sort-population pop #'list-min))

(setf popi pop)
(dotimes (i 10)
  (setf popi (next-generation (eval-sort-population popi #'list-min)))
  (format "Gen ~a: ~a~%" i (sum-mins popi)))

(sum-mins (setf popi (next-generation (eval-sort-population popi #'list-min))))

;;Typical population is # of jobs

SMALL JOB SHOP
(setf jobs (make-func-jobs 10 4 #'(lambda () (random 10)) #'(lambda () (random 100))))
(setf machines (make-serial-machines 4))


(test-basics jobs machines)
(setf small-job-pop (make-population 4 20))
(setf small-job-policy 
      (make-generation-policy
        :eval-func #'(lambda (a)
                       (sum-tardiness (run-jobs (arb-ordering jobs (genes-to-schedule a)) machines)))))
(setf small-job-pop1 small-job-pop)
(setf small-job-pop1 (next-generation 
                       (eval-sort-population 
                         small-job-pop1 
                         (generation-policy-eval-func small-job-policy)) small-job-policy))


(20,250)
(50,50)
(100,25) 
5 minutes
4 job sets x 3 pop sizes {20, 50, 100} x 3 runs x 1 min/gen
4 Machine 20 Jobs

(dotimes (i 3)
  (setf jobs (make-func-jobs 20 4 #'(lambda () (random 10)) #'(lambda () (random 150))))
  (setf machines (make-serial-machines 4))
  (test-basics jobs machines)
  (dotimes (k 3)
    (format t "********* ~A:~A:RUNNING (20, 125) ***********~%" i k)
    (learn-shop jobs machines 20 125 0))
  (dotimes (k 3)
    (format t "********* ~A:~A:RUNNING (50, 50) ***********~%" i k)
    (learn-shop jobs machines 50 50 0))
  (dotimes (k 3)
    (format t "********* ~A:~A:RUNNING (100, 25) ***********~%" i k)
    (learn-shop jobs machines 100 25 0)))


(setf jobs (make-func-jobs 20 4 #'(lambda () (random 10)) #'(lambda () (random 150))))
(setf machines (make-serial-machines 4))
(test-basics jobs machines)
(dotimes (i 3)
(format t "********* RUNNING (20, 200):~A ***********~%" i)
(learn-shop jobs machines 20 200 0))
(format t "********* RUNNING (50, 50) ***********~%")
(learn-shop jobs machines 50 50 0)
(format t "********* RUNNING (100, 25) ***********~%")
(learn-shop jobs machines 100 25 0)

(setf (bytes-consed-between-gcs) 100663296)


(setf jobs (make-func-jobs 20 4 #'(lambda () (random 10)) #'(lambda () (random 150))))
(setf machines (make-serial-machines 4))
(test-basics jobs machines)


(dotimes (i 3)
(format t "********* RUNNING (20, 100):~A ***********~%" i)
(learn-shop jobs machines 20 100 0))
|#    








